perm filename DRAWIT.F4[DRW,LCS]4 blob
sn#635556 filedate 1982-01-21 generic text, type T, neo UTF8
C******* DRAWIT, LIST ************
SUBROUTINE DRAWIT
COMMON /ED/K,NEXT,NN,NX,NY,J
COMMON /RZ/RSZ,RJB,CENTR /RC/MCLEF(1100),IST(1)
COMMON/ZN/SCLEF(2,1100) /LL/LL
1 /JJJ/JJJ
CIRC 1 /DPY/NDP,IOV
DIMENSION ITEM(20)
EQUIVALENCE(MM,SCLEF(1,1))
DATA RN/15./,REL/-1.0/
C INITIALIZED TO ABSOLUTE VECTORS. BUT CHANGE TO RELATIVE WILL BE STICKY.
C DISPLAYS OLD ITEM WITHOUT FILLER
REL=-1
CC JC=0
KE=-1
JCL=0
RJ=1
IF(MM.EQ.0)GO TO 20
J=MM
JX=-1
JCL=MM
NX=SCLEF(1,MM)
NY=SCLEF(2,MM)
GO TO 120
20 J=1
JZ=J
2 NX=RJB*RSZ
NY=CENTR*RSZ
121 JX=0
120 NZ=-1
JC=1
RL=NX
RM=NY
C L AND M ARE USED AS CONSTANTS WHEN RESETTING CURSOR
83 S=0
CALL SETCUR(NX,NY,0)
4 IF(S)GO TO 81
CJ NO MORE LIGHT PEN SELECTION. IF(K.EQ.'E')GO TO 700
IF(K.EQ.'E')GO TO 79
C BYPASS FOR EDITING.
CIRC CALL CURSOR(NX,NY)
C CALL SETCUR(NX,NY,0)
CALL DPYOUT(1)
45 FORMAT(' SET POINT ',$)
30 TYPE 45
ACCEPT 144,K,ZK,KK
CALL LO2UP(K)
CALL LO2UP(ZK)
CALL LO2UP(KK)
IF(ZK.NE.'I'.OR.K.NE.'L')GO TO 33
C TYPE 'LI' TO LIST ALL VECTORS
MCLEF(1)=J
CALL LIST(0)
GO TO 30
37 FORMAT(I4,') X,Y,Z= ',3I5)
33 IF(ZK.NE.'E')GO TO 344
REL=0
C TYPE 'REL' FOR RELATIVE VECTORS, 'A'=ABSOLUTE
TYPE 31
GO TO 30
31 FORMAT(' ***** RELATIVE VECTORS *****')
32 FORMAT(' ***** ABSOLUTE VECTORS *****')
344 IF(K.NE.'A')GO TO 244
REL=-1
TYPE 32
GO TO 30
144 FORMAT(3A1)
244 IF(ZK.NE.'M')GO TO 444
C TYPE SM TO SMOOTH, SMX=ERASE STRAIGHT LINES TEMPORARILY.
MCLEF(1)=J
CALL SMOOTH(KK)
GO TO 4
444 IF(ZK.NE.'X')GO TO 445
MCLEF(2)=MCLEF(2)+200000000
K='X'
GO TO 3
445 IF(ZK.EQ.'I')GO TO 447
C TYPE 'CI' TO GENERATE CIRCLES AND ARCS
446 REREAD 1,K,ZK,XK
CALL LO2UP(K)
IF(K.LT.'-'.OR.K.GT.'9')GO TO 40
C SKIP NON-NUMBERS
REREAD 11,RJ,RK,XK
JMPR=0
IF(XK.EQ.1)K='J'
C TYPE 3RD NUM=1 FOR JUMPS
IF(XK.EQ.2)K='F'
C IF 3RD NUM=2 -- BEGIN FILL SECTION
41 QJ=RJ
QK=RK
IF(REL.LT.0)GO TO 141
241 X=X+QJ*RSZ
Y=Y+QK*RSZ
NX=X
NY=Y
GO TO 48
141 NX=GTPT(RJ,RJB)
NY=GTPT(RK,CENTR)
X=NX
Y=NY
GO TO 481
40 KK=ZK
C B=BACKUP, J=JUMP, CR=SET POINT, X=EXIT, LRUD-N
C F=FILL IT, H=GO TO HOME-NUM, N=GO TO NEXT(AFTER AN 'H')
C Z=ZERO IN ON NEARBY POINT, P=GO TO PREVIOUS, C=CLOSE THE AREA
C D=EXTEND DRAWING, F=START FILLER OUTLINE, SM=SMOOTH IT
C TYPE 'FX' TO FILL ORIGINAL OUTLINE AND EXIT.
C L,R,U,D + NUM MOVES LAST POINT ENTERED.
IF(ZK.NE.0)NZ=-1
C WILL STAY IN "Z" MODE UNLESS NUMBER APPEARS.
JMPR=0
JCX=2
C JCX IS FOR "ZEROING-IN" SECTION AND EDIT SECTION
C FOR SHIFTS OF "JUMPS"
IF(K.EQ.'B')GO TO 22
IF(K.EQ.'C')GO TO 51
IF(K.EQ.'X')GO TO 3
IF(K.EQ.' ')GO TO 47
IF(K.EQ.'J')GO TO 47
IF(K.EQ.'Z')GO TO 47
IF(K.EQ.'S')GO TO 79
IF(K.EQ.'F')GO TO 47
IF(K.NE.'H')GO TO 7
52 IF(KK.LE.1)KK=2
X=SCLEF(1,KK)
Y=SCLEF(2,KK)
NEXT=KK+1
IF(KE)GO TO 48
RX=X
RY=Y
58 IF(NEXT.GT.J+1)GO TO 83
NN=JA-1
CALL ITYP
CALL EDTYP(K,X,Y,JJJ)
C TYPE "A" OR ":" TO ALTER
C TYPE "G"=GROUP CHANGE) TO MAKE RELATIVE CHANGE STICK
C , THEN <CR>S. ANY OTHER LETTER TO ESCAPE
IF(K.NE.'J')GO TO 573
C J=JUMP TO NEXT 'JUMP'
DO 574 K=NEXT,J
574 IF(MCLEF(K).GE.100000000)GO TO 575
575 X=K-NEXT+1
GO TO 82
573 IF(K.LT.'-')GO TO 1573
C NEXT FOR NUMBERS ONLY -- FOR STEP AHEAD AND BACK
2573 REREAD 11,X
GO TO 82
1573 IF(K.NE.'B')GO TO 570
X=-X
GO TO 82
570 IF(K.NE.' ')GO TO 1570
IF(S)GO TO 81
1570 IF(K.EQ.'S')GO TO 82
C S=STEP AHEAD(N) (-N OR B GOES BACK)
IF(K.EQ.'X')GO TO 3
IF(K.NE.'LI')GO TO 1571
C TYPE 'LI' TO LIST ALL VECTORS
CALL LIST(0)
GO TO 58
CIRC1571 IF(K.NE.'M'.AND.K.NE.'R')GO TO 572
1571 IF(K.NE.'M'.AND.K.NE.'R'.AND.K.NE.'Q')GO TO 572
C M OR R ALONE WILL MOVE LAST SET OF POINTS MOVED. BUT BE CAREFUL!
C Q REPEATS LAST COMMAND.
LL=0
IF(X+Y.EQ.0)GO TO 580
IF(X.OR.Y.EQ.0)GO TO 577
C "M -N1, N2, N3" MOVES WHOLE BLOCKS (OR "M N1 0")
C OR USE 'R' FOR 'M' TO ROTATE GROUP OF POINTS
C TO SET ITEM # N2}0, SETS ITEM # TO N3 IF N3}0.
NY=Y-X+2
NX=X+1
576 MX=NX
MY=NY
580 CALL SHIFT(MCLEF(MX),MY,K)
C TO MOVE SEGS MX THROUGH MY.
CIRC CALL DPYCLR
CALL HYDPOG(1)
C CALL POG1
CALL RDRAW(1,2,MCLEF(1),MCLEF)
CIRC CALL RDRAW(2,MCLEF(1),MCLEF)
CIRC CALL DPYOUT(NDP)
C CALL DPYOUT(1)
GO TO 58
577 NX=ABS(X)
IF(Y.NE.0)GO TO 578
CALL UNPACK(NX,NY,LL,ITEM(NX))
GO TO 576
578 NY=ABS(Y)
IF(JJJ.NE.0)GO TO 579
IK=IK+1
TYPE 46,IK
JJJ=IK
IF(JJJ.GT.10)GO TO 58
579 LL=0
NY=NY-NX+2
NX=NX+1
JB=NX
CALL REPACK(JB,NY,LL,ITEM(JJJ))
GO TO 576
572 MCLEF(1)=J
IF(K.EQ.'F')GO TO 470
C TAKE OUT OTHER 'F'S IN DREDIT*****
571 CALL DREDIT
59 X=RX
Y=RY
KE=-1
NX=0
NY=0
GO TO 170
C THIS WRECKS "CLOSE"
470 MCLEF(NEXT-1)=MCLEF(NEXT-1)+200000000
K='X'
GO TO 34
47 IF(REL.EQ.0)GO TO 22
C IF IN "REL" MODE TYPE "O" BEFORE USING LTPEN
CALL RDCUR(NX,NY)
C THIS FOR STANFORD ONLY
X=NX
Y=NY
IF((K.NE.'Z'.AND.NZ).OR.K.EQ.'J'.OR.K.EQ.'F')GO TO 48
NZ=0
DO 54 K=JCX,JCL
IF(ABS(SCLEF(1,K)-X).GT.RN.OR.ABS(SCLEF(2,K)-Y).GT.RN)
1 GO TO 54
KK=K
GO TO 52
54 CONTINUE
IF(KE)GO TO 48
C KE=-1 = DRAW MODE (NOT EDIT)
TYPE 154
GO TO 4
154 FORMAT(' NO POINT FOUND ')
C ABOVE FOR INITIAL MOVEMENT OF CURSOR
51 DO 151 K=J,1,-1
IF(MCLEF(K).LT.100000000)GO TO 151
C FIND LAST JUMP TO CLOSE THE AREA
RX=SCLEF(1,K)
RY=SCLEF(2,K)
GO TO 251
151 CONTINUE
251 X=RX
Y=RY
48 RJ=STPT(X,RJB)
RK=STPT(Y,CENTR)
481 SK=RK
J=J+1
551 SJ=RJ
C DO I NEED RJ,RK ANYWHERE?? YES - AT REPACK
451 LL=0
IF(K.EQ.'J')LL=100000000
C J=JUMP
IF(K.NE.'F')GO TO 452
K='J'
253 LL=200000000
452 IJ=RJ
IK=RK
JCL=J
CALL REPACK(IJ,IK,LL,MCLEF(J))
IF(MCLEF(J).NE.MCLEF(J-1).OR.J.EQ.2)GO TO 60
61 J=J-1
GO TO 4
60 SCLEF(1,J)=X
SCLEF(2,J)=Y
50 X=GTPT(SJ,RJB)
Y=GTPT(SK,CENTR)
NX=X
NY=Y
IF(K.EQ.'B')GO TO 5
IF(K.EQ.'J'.OR.JMPR.OR.JX.EQ.0)GO TO 6
CIRC CALL VECT(IOV,NX,NY,0)
CALL AVECT(NX,NY)
GO TO 5
CIRC6 CALL VECT(IOV,NX,NY,1)
6 CALL AIVECT(NX,NY)
JX=-1
JMPR=-1
C KZ IS FOR "CLOSE IT"
NZ=-1
RX=X
RY=Y
5 L=J-1
TYPE 46,L,SJ,SK
170 CALL SETCUR(NX,NY,JC)
GO TO 4
CIRC170 GO TO 4
74 FORMAT(' S(TEP) OR L(IGHT PEN)? ',$)
7 IF(K.NE.'E')GO TO 71
C E=EDIT
71 IF(ZK.EQ.0)ZK=1
IF(K.EQ.'L'.OR.K.EQ.'D')ZK=-ZK
IF(K.EQ.'L'.OR.K.EQ.'R')GO TO 77
SK=ZK+SK
Y=GTPT(SK,CENTR)
GO TO 78
77 SJ=ZK+SJ
X=GTPT(SJ,RJB)
CIRC78 CALL DELVEC(J,J)
78 CALL BUP
C DELETE THE LAST VECTOR FROM THE DPY BUFFER.
J=J-1
C DECREMENT THE VECTOR COUNTER
GO TO 48
79 S=-1
JA=ZK-1
84 IF(JA.LT.2)JA=1
81 IF(K.NE.'D')JA=JA+1
IF(JA.GT.J)JA=J
X=SCLEF(1,JA)
Y=SCLEF(2,JA)
NX=X
NY=Y
NEXT=JA+1
CIRC CALL CURSOR(NX,NY)
CALL SETCUR(NX,NY,0)
GO TO 58
82 IF(X.EQ.0)X=-1
JA=JA-1+X
GO TO 84
22 IF(J.EQ.JZ)GO TO 4
C CAN'T BACKUP PAST 1 OR 'F'
CIRC CALL DELVEC(J,J)
CALL BUP
C DELETE LAST VECTOR FROM DPY BUFFER.
J=J-1
C J IS VECTOR COUNT
122 CALL UNPACK(IJ,IK,LL,MCLEF(J))
SJ=IJ
SK=IK
IF(K.EQ.'B')GO TO 50
RJ=RJ+QJ
RK=RK+QK
GO TO 241
3 MCLEF(1)=J
IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
34 CALL CLRCUR
IF(K.NE.'X')GO TO 120
RETURN
1 FORMAT(A1,2F)
11 FORMAT(3F)
46 FORMAT(I3,'.)',2F6.0/)
447 JOLD=J
3447 TYPE 107
147 FORMAT(' TYPE RADIUS 1 AND RADIUS 2 '$)
ACCEPT 1,K
IF(K.NE.'B')GO TO 5447
2447 J=JOLD
GO TO 5
5447 REREAD 11,RAD,RADX
C PUT IN LIGHT PEN FEATURE HERE.
IF(RADX.EQ.0)RADX=RAD
C SAVE J FOR RETRY
4447 TYPE 247
247 FORMAT(' DEGREES OF 1ST AND LAST POINT (<CR>=0,360) '$)
ACCEPT 1,K
IF(K.EQ.'B')GO TO 3447
REREAD 11,D1,D2
IF(D1.EQ.0.AND.D2.EQ.0)D2=360
TYPE 347
347 FORMAT(' TYPE NUMBER OF VECTORS (<CR>=36) '$)
ACCEPT 1,K
IF(K.EQ.'B')GO TO 4447
REREAD 11,DD
IF(DD.EQ.0)DD=36
RADX=(RADX-RAD)/DD
JD1=D1
JD2=D2
DD=(D2-D1)/DD
XX=SJ-SIND(D1)*RAD
C GET OFFSET FOR X AND Y BASED ON RADIUS AND 1ST POINT IN DEGREES
YY=SK-COSD(D1)*RAD
C X AND Y WERE LAST POINTS SET
JST=IST(2)
C SAVE DPY POINTER IN CASE CURVE IS REJECTED
CC DIMENSION JCIR(2,360)
847 JJ=0
C DO 547 K=JD1,JD2,KK
C947 JJ=JJ+1
947 J=J+1
D1=D1+DD
A=D1
IF(A.GT.360.)A=A-360.
XA=SIND(A)*RAD+XX
Y=.5
IF(XA)Y=-Y
NX=XA+Y
XA=NX
C FOR ROUND-OFF
X=GTPT(XA,RJB)
NX=X
XB=COSD(A)*RAD+YY
A=.5
IF(Y)A=-A
NY=XB+A
XB=NY
Y=GTPT(XB,CENTR)
NY=Y
RAD=RAD+RADX
CALL AVECT(NX,NY)
C JCIR(1,JJ)=XA
C JCIR(2,JJ)=XB
SCLEF(1,J)=XA
SCLEF(2,J)=XB
C547 TYPE 46,JJ,XA,XB
CC D1=D1+DD
IF(DD.LT.0)GO TO 1447
1147 IF(D1.LT.D2)GO TO 947
GO TO 1247
1447 IF(D1.GE.D2)GO TO 947
1247 CALL DPYOUT(1)
TYPE 647
647 FORMAT(' ALL O.K.? '$)
ACCEPT 1,K
IF(K.NE.'N')GO TO 747
IST(2)=JST
CALL ACCPOG(1)
CALL DPYOUT(1)
J=JOLD
GO TO 3447
747 CALL SETCUR(NX,NY)
LL=0
C DO 1547 K=1,JJ
DO 1547 K=JOLD+1,J
C J=J+1
C NOW PUT THE CURVE INTO THE ARRAY
MX=SCLEF(1,K)
MY=SCLEF(2,K)
1547 CALL REPACK(MX,MY,0,MCLEF(K))
C1547 CALL REPACK(JCIR(1,K),JCIR(2,K),LL,MCLEF(J))
JCL=J
SJ=SCLEF(1,J)
SK=SCLEF(2,J)
C GO TO 4
GO TO 5
END
SUBROUTINE LIST(N)
COMMON /RC/MCLEF(1)
CC COMMON /ED/I,NEXT,NN,NX,NY,J /RC/MCLEF(1)
CIRC IF(N.NE.0)OPEN(UNIT=1,FILE=N)
IF(N.NE.0)CALL OFILE(1,N)
C NEXT WILL LIST ALL VECTORS
DO 35 K=2,MCLEF(1)
C J ALWAYS POINTS TO LAST VECTOR IN MCLEF ARRAY. (MCLEF(1)=WDCOUNT)
CALL UNPACK(JX,JY,JZ,MCLEF(K))
JK=K-1
JZ=JZ/100000000
IF(N.NE.0)WRITE(1,2)JK,JX,JY,JZ
35 IF(N.EQ.0)TYPE 37,JK,JX,JY,JZ
IF(N.EQ.0)RETURN
CIRC CLOSE(UNIT=1)
END FILE 1
2 FORMAT(4I5)
37 FORMAT(I4,') X,Y,Z= ',3I5)
END